MacWorld 1999 July/Macworld (1999-07).dmg/Shareware World/Info/For Developers/Mops 3.4.sea/Mops source/PPC source/zArgs

Text File | 1998-12-18 | 11KB | 455 lines

\ zArgs - support for named parms and local variables


(*    This file is the PPC equivalent of the 68k "Args" file.  It's a
    "z" file - it's not target compiled, but is loaded on the PPC itself.
    Args has EVALUATE - the PPC EVALUATE has already been target compiled
    in pArgs since we needed it earlier.  Here we include everything else.
*)


    11    constant    MAXPL        \ We can only spare 11 regs on PPC,
                                   \  or 10 if we use I (r21).
       15    constant    MAXFPL
       15    constant    MAXVL

false    value        LOCFLG        \ true = looking for local var tokens
    0    value        LOC_ADDR
false    value        storing?

create    PARMLIST    maxPL cells 8 +  reserve
create    PARMFLAGS    maxPL reserve
create    FPARMLIST    maxFPL cells 8 +  reserve
create    FPARMFLAGS    maxFPL  reserve


    0    value    svhash
false    value    float?
    0    value    PLentry_addr


: INITLOCS        \ Initializes flags etc.
    0 -> #PL  0 -> #P  0 -> #FPL  0 -> #FP
    0 -> FltFlg  false -> locFlg
;

: undef_check  ( parmflags #P i parmlist -- index )
    - 4/ dup >r
    tuck <  localSect? not and
    IF    +
        storing?
        IF        1 swap c!
        ELSE    c@  NIF  112 die  THEN
        THEN
    ELSE  2drop
    THEN
    r>
;


: FINDINPARMLIST        \ ( addr -- loc# T  OR  -- F )
            \ loc# counts from right to left in the local/parm list.
    dup 1+ c@   & %  =  -> float?
    hash -> svHash  false

    float?
    IF        #FPL  0EXIT  fparmlist  #FPL
    ELSE    #PL   0EXIT  parmlist   #PL
    THEN
    4*  bounds
    DO
        svHash  i @ =
        IF  ( found )
            drop
            float?
            IF
                #FPL
                fparmflags #FP i fparmlist  undef_check
            ELSE
                #PL
                parmflags #P i parmlist  undef_check
            THEN
            -  1-  true  LEAVE
        THEN
    4 +LOOP
;


: ADDTOPARMLIST        \ ( addr -- )  Adds an element to parmList.
                    \  addr points to a counted string.

    findinParmList  ?error 95        \ Name not unique
    #PL  maxPL  >  ?error 110        \ too many parms/locals
    svHash
    float?
    IF    #FPL 1 ++> #FPL 4*  fParmlist +  !
        locFlg NIF  1 ++> #FP  THEN
    ELSE
        #PL  tuck 1 ++> #PL  4*  parmlist  +  !
        parmflags +  0 swap c!
        locFlg NIF  1 ++> #P  THEN
    THEN
;


: FIRSTCHR  ( -- c )        \ assumes CDP is aligned - which should
                            \  always be the case here.
    inline{ CDP 1+ c@}  ;


: gobble_to_}
    BEGIN
        firstChr  & }  <>
    WHILE
        Mword drop
    REPEAT
;


:f {
    local? IF            \ local? already non-zero - this ought to mean we're
                        \  in a local section
        local? 0< ?error 92  -1 -> local?
    THEN
    initLocs

    BEGIN                    \ Loop to add parms/locals to parmlist
        Mword drop
        firstChr  & -  <>            \ look for --
    WHILE
        firstChr dup  & \  =  swap  & /  =  or
                \ Note: we allow / as an alternative to \ in this context,
                \  since it's an easy mistake to make, and / isn't a
                \  sensible parm name since it already has a meaning!

        IF        true -> locFlg
        ELSE    firstChr  & } =  ?error 111
                CDP  addToParmList
        THEN
    REPEAT

    local? NIF                \ In local sections, we do this at :LOC
        CDP  -> PLentry_addr
            \  If we have temp objects, we'll have to backup the DP and
            \  recompile the entry sequence, since there'll be an extra local
            \  (the frame pointer)
        PLentry
    THEN

(*    Finally we gobble input until }.  But if we're in a :ENTRY,
    we also need to check if a % comes first, as that's the way
    we declare a floating result.  If we don't get a %, we assume
    an integer result.
*)
    entry?
    IF
        Mword drop  firstChr  & % =
        IF
            0 -> gpr_rtn_cnt  1 -> fpr_rtn_cnt
        ELSE
            0 -> fpr_rtn_cnt
            firstChr & } <>  negate  -> gpr_rtn_cnt
        THEN
    THEN

    gobble_to_}
;f


\ FIND will call the forward-defined initFind first, to attempt to find
\  a name.  At this stage in building the system we need to look for
\  named parms & locals, so we define a word pFind which looks for them,
\  and resolve initFind to pFind.  Later we'll re-resolve initFind to look
\  for selectors, etc. as well as calling pFind.

\  If pFind finds the name is a parm/local, it returns true and the
\  cfa of LocParm, which is a dummy word whose handler compiles
\  a local reference.

: PFIND        \ ( str-addr -- cfa T  |  -- str-addr F )
    state        NIF  false  EXIT  THEN
    #PL #FPL or    NIF  false  EXIT  THEN

    dup  findInParmList  NIF  false  EXIT  THEN

\ found it!

    -> loc#  drop
    float? IF  <'> FlocParm  ELSE  <'> locParm  THEN
    true
;

:f initFind  pFind  ;f


: ,EXEC        \ ( cfa n -- )
    state
    IF  (compN)  ELSE  exN  THEN  ;

\ Here are the different types that we can put prefixes on or send
\ messages to:

enum{    notfnd  locTyp  flocTyp
        tmpObjTyp  objTyp  ivarTyp  classTyp  superTyp
        valTyp  fvalTyp  vecTyp  dynVecTyp  objptrTyp
        regTyp  lbTyp  lbSelfTyp  bktTyp  wordTyp  }


(*    notFnd    - not previously defined
    locTyp    - a local or named parm
    tmpObjTyp    - a temporary (local) object
    objTyp    - an object
    ivarTyp    - an ivar
    classTyp    - a class
    superTyp    - a named superclass specified by  msg: super> someClass
    valTyp    - a value
    FvalTyp    - a floating point value
    vecTyp    - a vector
    dynVecTyp    - a dynamic vector
    regTyp    - a 680x0 register
    lbTyp        - ** or [] meaning late bind
    lbSelfTyp    - [self] meaning late bind to self
    BktTyp    - [ - Neon-compatible late bind
    wordTyp    - a word
*)

: HDLR    ( xt - handler_code )
    inline{ 2- w@}  ;

\ PRFTOKEN returns the type of a token for a prefix op.

: PRFTOKEN    \ ( -- cfa type )

    '  dup  <'> locParm  =  IF  locTyp    EXIT  THEN
       dup  <'> FlocParm =  IF  FlocTyp    EXIT  THEN
    dup  hdlr
    CASE
        $ BC03        OF    valTyp        ENDOF
        $ BC27        OF    FvalTyp        ENDOF
        $ BC05        OF    vecTyp        ENDOF
        $ BC3D        OF    vecTyp        ENDOF    \ sVect
        $ BC3B        OF    dynVecTyp    ENDOF
        $ BD0A        OF    regTyp        ENDOF
        $ BC1F        OF    objPtrTyp    ENDOF
        114 die
    ENDCASE  ;

forward    ToObjPtr        \ Stores to an objPtr.  Defined in file Class.

: ->
    true -> storing?
    prfToken                \ All types are legal
    false -> storing?
    objPtrTyp =  IF  toObjPtr  EXIT  THEN
    $ 60  ( opcode for Store )  ,exec
;        immediate            \ NOTE: opcode for store hard coded here!!!


: CvrtFcode    \ ( code -- code' )
    CASE
        $ 21  OF  $ 41  ENDOF        \ +
        $ 22  OF  $ 48  ENDOF        \ -
        $ 28  OF  $ 55  ENDOF        \ Neg
        ?error 114
    ENDCASE  ;

: (+->)        \ ( code -- cfa code' )
    PrfToken ( code cfa type )  rot swap ( cfa code type )

    CASE
        locTyp        OF                ENDOF
        FlocTyp        OF  cvrtFcode    ENDOF
        valTyp        OF                ENDOF
        FvalTyp        OF  cvrtFcode    ENDOF
        regTyp        OF                ENDOF
        ?error 114
    ENDCASE  ;

: (FOP)
    PrfToken  rot swap
    CASE
        locTyp        OF  ENDOF
        FlocTyp        OF  ENDOF
        FvalTyp        OF  ENDOF
        ?error 114
    ENDCASE  ;


\ Note: the following opcodes have to agree with the definitions in
\ OD.asm.  I could have defined them as constants but this would have
\ used up dictionary space for no great benefit.

: ++>    $ 21  (+->)  ,exec  ;        immediate
: +>    postpone  ++>       ;        immediate        \ A synonym.
: -->    $ 22  (+->)  ,exec  ;        immediate
: AND>    $ 23  (+->)  ,exec  ;        immediate
: OR>    $ 24  (+->)  ,exec  ;        immediate
: XOR>    $ 25  (+->)  ,exec  ;        immediate
: NEG>    $ 28  (+->)  ,exec  ;        immediate
: NOT>    $ 29  (+->)  ,exec  ;        immediate
: *>    $ 42  (fop)  ,exec  ;        immediate
: />    $ 49  (fop)  ,exec  ;        immediate
: ABS>    $ 54  (fop)  ,exec  ;        immediate


\ ' Pfind  -> Ufind

\         =========== Local sections ===========


forward        INITTEMPS

: ?LOC    local? 0=  ?error 91  ;            \ "We're not in a local section"


: LOCAL
    local?  ?error 93  1 -> local?        \ We change it to the normal -1
                                        \ as soon as "{" is read.
    true -> localSect?
    CDP -> CD_gpr_loc
    forward                                \ LOCAL is just like FORWARD
    CDP 4- -> loc_addr
;


: :LOC
    local? 1 = IF  msg# 96  THEN    \ warning  - no locals defined
    ?loc
    ' drop                            \ gobble word name

    CDP -> const_data_start            \ the following is like :f (see qpCond)
    $ BE020000  code,                \ marks this as the :loc position
                                    \  (just for disassembly)

    false -> method?
    false -> local?                    \ so entry sequence gets compiled
    true ppc_entry                    \ handle ppc proc entry.  We're handling
                                    \  local sections by calling FORWARD,
                                    \  so we need to tell ppc_entry this
                                    \  is a forward defn so the parms get
                                    \  handled properly.
    fwd_gpr_rtn_cnt  -> gpr_rtn_cnt
    fwd_fpr_rtn_cnt  -> fpr_rtn_cnt
    drop 304                        \ security marker for :loc
    curr-def
      loc_addr -> curr-def
      PLentry
    -> curr-def
    tempObj_block_size IF  initTemps  THEN
;        immediate

: ;LOC
    304 ?defn
    false -> leaf?            \ let's just reduce the bug possibilities!
    loc_addr 2-  (;)
    loc_addr curr-def  resolve_unconditional_branch
                            \ resolve the forward branch from LOCAL
    false -> localSect?
;            immediate


\            ============================================

\ EVALUATE was already loaded in pArgs, along with the value compinline?.

: (COMPINL)        \ ( xt -- )

    true -> compinline?
    2+ count  evaluate
    false -> compinline?  ;

' (compinl) -> compinline


: [IF]  { flag \ addr len level done? -- }

    flag  ?EXIT
    false -> done?  1 -> level

    BEGIN
        Mword count  -> len  -> addr
                addr len  " [THEN]" s=  IF  1 --> level
        ELSE    addr len  " [ELSE]" s=    IF  level 1 =
                                            IF  true -> done?  THEN
        ELSE    addr len  " [IF]"   s=  IF  1 ++> level
        THEN THEN THEN

        level  NIF  true -> done?  THEN
        done?
    UNTIL
;                immediate


: [ELSE]  { \ addr len level done? -- }
    false -> done?  1 -> level
    BEGIN
        Mword count  -> len  -> addr
                addr len    " [THEN]" s=  IF  1 --> level
        ELSE    addr len    " [IF]"   s=  IF  1 ++> level
        THEN THEN

        level  NIF  true -> done?  THEN
        done?
    UNTIL
;                immediate


: [THEN]  ;        immediate



(*    INSTEAD ( c-old c-new -- )  may be used just after a SCON is defined.
    Within the SCON, it replaces any occurrences of c-old with c-new.  This
    operation is useful for creating SCONs containing special characters
    such as tab.
    This logically should come after SCON in zBase, but it needs locals
    so we'll put it here.
*)

: INSTEAD  { c-old c-new -- }
    latest name> ex-gen  bounds        \ SCONs use DOES> so require EX-GEN
    DO   i c@ c-old = IF  c-new i c!  THEN
    LOOP  ;


\                    =============================
\                            ASSERTIONS
\                    =============================

(*    Assertions allow you, during development, to ensure that
    things are the way they're supposed to be at key places.

    Usage:
    ASSERT{ <something that evaluates to a flag> }

    If ASSERTIONS? is true, this will give error 216 ("assertion failed")
    if the evaluated flag is false.  If ASSERTIONS? is false, nothing
    will happen - the code between ASSERT{ and } isn't executed.

    ASSERTIONS? can be defined and redefined however and whenever you
    like, as long as it returns a flag - ASSERT{ tests it via EVALUATE,
    so the latest definition will always be the one that gets looked at.
    If you have ASSERTIONS? defined as a constant with value false, no
    code will even be compiled for the assertion test - you can use this
    for code that you know works.

    The initial version of ASSERTIONS? is in the file Setup.
*)

: }ASSERT
    134 ?pairs
    ['] } >body !                    \ restore old action for "}"

    " NIF 216 die THEN THEN"  evaluate        \ assertion failed!
;        immediate


: ASSERT{
    ?comp
    " assertions? if" evaluate

    ['] } >body @                \ save old action for "}"
    ['] }assert  -> }            \ "}" will now be same as }assert
    134
;        immediate